perm filename PARTS.F4[MSS,LCS]2 blob sn#134996 filedate 1974-12-12 generic text, type T, neo UTF8
00100	C THIS AIDS IN EXTRACTING PARTS FROM SCORES.
00200		COMMON PWDS(250),RN(2000)
00300		1,LP,TR,XWDS(250),XN(2000)
00350		DIMENSION ST(8)
00400	
00500	12	TYPE 1
00600		REWIND 21
00700		ACCEPT 2,N
00710		IF(N.NE.'HELP')GO TO 13
00720		TYPE 14
00730		GO TO 12
00740	14	FORMAT(' FOR "WHICH STAFF#?"  GIVE N1, N2, N3'/'
00750		1 N2=TRANSP. STEPS,  N3=1=WILL BE SAME FOR ALL FILES'/)
00800	13	CALL OFILE(21,N)
00900		XWDS(1)=1
01000		RM=0
01100	CC	RS=4
01200		L=1
01300	CC	LK=1
01400		LP=1
01500		TYPE 44
01600		ACCEPT 5,RS
01700	10	TYPE 3
01710		LK=LP
01800		REWIND 22
01900		ACCEPT 2,NM
02000		IF(NM.EQ.' ')GO TO 20
02100		CALL IFILE(22,NM)
02110		JZ=0
02200		IF(RM.NE.0)GO TO 30
02300		TYPE 4
02400		ACCEPT 5,SN,TR,RM
02500	C TYPE 2ND NUM FOR TRANSPOSE, 3RD NUM FOR ALWAYS SAME STFF.
02550	30	J=1
02600		READ(22),ITEM,I,(PWDS(K),K=1,ITEM+1),(RN(K),K=1,I-1)
02650		1,J,J,J,J,RS,ST,K
02700	CC	IF(L+ITEM.LE.250.AND.LP+I.LE.2000)GO TO 8
02800	8	DO 6 K=1,ITEM
02900		J=PWDS(K)
03000		IF(RN(J+1).NE.4)GO TO 80
03100		IF(RN(J).NE.2)GO TO 80
03200	C  FOUND A BAR LINE
03300		RN(J+4)=1
03310		KC=RN(J+2)*10
03320		DO 82 KA=K+1,ITEM
03330		KB=PWDS(KA)
03340		IF(RN(KB+1).NE.4.OR.RN(KB).NE.2)GO TO 82
03350	C  AVOIDS DUPLICATE BARS.
03360		KD=RN(KB+2)*10
03370		IF(KC.EQ.KB)RN(KB+1)=0
03380	82	CONTINUE
03400		GO TO 81
03500	80	IF(RN(J+3).NE.SN)GO TO 6
03510		JZ=-1
03600	81	JA=PWDS(K+1)
03700		DO 7 KA=J,JA-1
03800		XN(LK)=RN(KA)
03900	7	LK=LK+1
03910		IF(L.LT.250.AND.LK.LE.2000)GO TO 50
03932		TYPE 9
03954		GO TO 20
03976	16	FORMAT(' STAFF NOT FOUND'/)
04000	50	R=XN(LP+1)
04100		IF(TR.NE.0.AND.(R.EQ.1.OR.R.EQ.8.OR.R.EQ.9))CALL TRANSP
04200		XN(LP+3)=RS
04600		L=L+1
04700		LP=LK
04800		XWDS(L)=LP
04900	6	CONTINUE
04910		IF(JZ)GO TO 17
04920		L=JX
04930		LP=JY
04940		TYPE 16
04950		GO TO 10
04960	17	JX=L
04970		JY=LP
05000		RS=RS-1
05100		IF(RS.GT.-4)GO TO 10
05200	20	L=JX-1
05300		J=1
05400		WRITE(21),L,JY,
05500		1 (XWDS(K),K=1,L+1),(XN(K),K=1,JY-1),J,J,J,J,RS,ST,K,K
05600	15	END FILE 21
05700	1	FORMAT(' TYPE OUTPUT FILE NAME'/)
05800	2	FORMAT(A5)
05900	3	FORMAT(' TYPE FILE NAME'/)
06000	4	FORMAT(' WHICH STAFF # ?'/)
06100	5	FORMAT(5F)
06200	9	FORMAT(' NO ROOM FOR THIS ONE')
06300	44	FORMAT(' TYPE TOP STAFF #'/)
06400		END
06500	
06600		SUBROUTINE TRANSP
06700		COMMON PWDS(250),RN(2000)
06800		1,LP,TR,XWDS(250),XN(2000)
06900		A=XN(LP+4)
07000		XN(LP+4)=A+TR
07100	C TRANSPOSES ONLY BY STAFF STEPS FOR NOW
07110		X=XN(LP+5)
07200		IF(XN(LP+1).EQ.1)GO TO 11
07210		XN(LP+5)=X+TR
07300		RETURN
07310	11	IF(AMOD(TR+16.0,8.0).NE.2)RETURN
07320	C  NEXT IS FOR Bb TRANSP.
07330		B=AMOD(A+7.0,7.0)
07340		IF(B.NE.0.AND.B.NE.3)RETURN
07350	C  FINDS ORIG. E OR B
07360		K=AMOD(X,10.0)
07370	C  FINDS ACCID.
07380		X=X-K
07390	C  STEM DIR. AND DECI.
07395		B=0
07400		IF(K.EQ.0.OR.K.EQ.3)B=2
07410	C  NO PROVISION YET FOR ## OR bb
07420		XN(LP+5)=X+B
07430		RETURN
07440		END